;; generic/generic.scm - (c) rohan drape, 2003-2004

;; A simple minded type based multiple argument dispatch generic
;; function constructor.

;; The global generic table.  Each value is a <method-table>.  The
;; table is indexed by a <symbol>, the name of the generic.

(define-global generic-table (make-table))

;; Is '#t' iff `name' is a known generic.

(define (generic-exists? name)
  (table-get* (generic-table) name))

;; Add an entry for `name'.

(define (generic-table-put! name)
  (if (generic-exists? name)
      (error "generic-table-put!: exists" name))
  (table-put! (generic-table) name (make-method-table)))

;; Fetch the <method-table> for the generic `name'.

(define (generic-method-table name)
  (if (not (generic-exists? name))
      (error "generic-method-table: no such generic" name))
  (table-get (generic-table) name))

;; Bind at `name' a procedure that will dispatch to the appropriate
;; method given it's arguments.  This <method-table> is stored before
;; the procedure is defined, there is no lookup when dispatching a
;; method.

(define-syntax define-generic*
  (syntax-rules ()
    ((_ name)
     (begin
       (generic-table-put! 'name)
       (set! name 
	 (let ((table (generic-method-table 'name)))
	   (lambda arguments (method-table-dispatch table arguments))))))))

;; Variant that requires `name' be unbound.

(define-syntax define-generic
  (syntax-rules ()
    ((_ name) 
     (begin (define name #f)
	    (define-generic* name)))))

